{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  OchreLang.Utils
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Utils.
--
--------------------------------------------------------------------------------

module OchreLang.Utils
  (


  -- * Monadic combinators
    repeatM
  , passM

  -- * Showing numbers
  , truncatedDouble

  -- * PP combinators
  , padTextR
  , blank_doc
  , vsep
  , vspaced
  , commaSep
  , tupled
  , semiBraces
  , commaBraces
  , commaBrackets
  , vsemiBraces

  , updateRefB
  , readRefU

  , seEmptyList
  , seElementsH
  , seElementsV
  , seConstrH
  , seConstrV

  -- * Hughes list
  , H  
  , emptyH
  , wrapH
  , consH
  , snocH
  , appendH
  , toListH

  ) where

import Text.PrettyExprHPJ                       -- package: pretty-expr-hpj

import Text.PrettyPrint.HughesPJ                -- package: pretty

import Numeric


--------------------------------------------------------------------------------
-- Monadic combinators

repeatM :: Monad m => Int -> (a -> m a) -> a -> m a
repeatM count mf = go count
  where
    go i a | i <= 0    = return a
           | otherwise = mf a >>= go (i-1)



passM :: Monad m => (a -> m z) -> a -> m a
passM mz a = mz a >> return a


--------------------------------------------------------------------------------
-- Showing numbers


showFFloat_ :: RealFloat a => a -> String
showFFloat_ = ($ "") . showFFloat Nothing


-- | Truncate the printed decimal representation of a Double.
-- This may be prefered to 'showFFloat' from Numeric as it 
-- produces shorter representations when the value has trailing
-- zeros.
-- 
-- 0.000000000 becomes 0.0 rather than however many digits are 
-- specified.
--  
truncatedDouble :: Double -> String
truncatedDouble d 
    | abs d < 0.0001  = "0.0"
    | d < 0.0         = '-' :  showFFloat_ (abs tx)
    | otherwise       = showFFloat_ tx
  where
    tx :: Double
    tx = (realToFrac (roundi (d*1000000.0))) / 1000000.0

roundi :: RealFrac a => a -> Integer
roundi = round


--------------------------------------------------------------------------------
-- PP combinators

padTextR :: Int -> String -> Doc
padTextR i ss | len <- length ss
              , len < i           = text ss <> text (replicate (i -len) ' ')
padTextR _ ss                     = text ss


-- | blank_doc - can be used to make blank lines whereas @empty@
-- is absorbed.
--
blank_doc :: Doc
blank_doc = zeroWidthText ""


vsep :: [Doc] -> Doc
vsep []     = empty
vsep [d]    = d
vsep (d:ds) = d $+$ vsep ds

vspaced :: [Doc] -> Doc
vspaced []     = empty
vspaced [d]    = d
vspaced (d:ds) = d $+$ blank_doc $+$ vspaced ds


commaSep :: [Doc] -> Doc
commaSep []     = empty
commaSep [a]    = a
commaSep (a:as) = a <> comma <+> commaSep as


tupled :: [Doc] -> Doc
tupled ds = parens $ hcat $ punctuate comma ds

semiBraces :: [Doc] -> Doc
semiBraces = braces . hcat . punctuate semi

commaBraces :: [Doc] -> Doc
commaBraces = braces . hcat . punctuate comma

commaBrackets :: [Doc] -> Doc
commaBrackets = brackets . hcat . punctuate comma


vsemiBraces :: [Doc] -> Doc
vsemiBraces []      = text "{ }"
vsemiBraces (d1:ds) = vcat (lbrace <+> d1 : map (\d -> semi <+> d) ds) $+$ rbrace




-- Need a new operator that is not present in Haskell, lower 
-- precedence than &&.
--
updateRefB              :: DocE -> DocE -> DocE
updateRefB              = Binary (infixR 1) (spaced ":=")


-- | Read a Ref cell.
-- 
-- > ! (unary)
--
readRefU                 :: DocE -> DocE
readRefU                 = Unary (prefix 9) (noSpace "!")


seEmptyList :: Doc
seEmptyList = text "()"

seElementsH :: [Doc] -> Doc
seElementsH ds = parens (hsep ds)

seElementsV :: [Doc] -> Doc
seElementsV ds = parens (vsep ds)

seConstrH :: String -> [Doc] -> Doc
seConstrH name ds = parens (text ('%':name) <+> hsep ds)

seConstrV :: String -> [Doc] -> Doc
seConstrV name ds = parens (text ('%':name) <+> vsep ds)



--------------------------------------------------------------------------------
-- Hughes list

type H a = [a] -> [a]

emptyH :: H a
emptyH = id

wrapH :: a -> H a
wrapH a = (a:)

consH :: a -> H a -> H a
consH a h = (a:) . h

snocH :: H a -> a -> H a
snocH h a = h . (a:)

appendH :: H a -> H a-> H a
appendH = (.)

toListH :: H a -> [a]
toListH h = h []

